home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops ƒ / Struct < prev    next >
Text File  |  1993-02-02  |  20KB  |  820 lines
  1. \ Standard data structure classes
  2.  
  3. \ May  91        Added Longword
  4. \ June 91        Reimplemented ordered-col etc. using multiple inheritance
  5. \ May  92        Added obj-array
  6. \ July 92        Fixed OBJ: ObjHandle to use NPTR: instead of PTR:
  7. \                HandleArray now inherits from Obj_array.
  8. \ Dec 92        Replaced UGET: in Int and Byte with new classes UINT and UBYTE.
  9.  
  10.  
  11. :class    LONGWORD  super{ object }    \ Generic superclass for var, handle etc.
  12.  
  13.     4    bytes    data
  14.  
  15. :m CLEAR:    inline{ 0 obj !}    0 ^base !  ;m
  16. :m GET:        inline{ obj @}        ^base @  ;m
  17. :m PUT:        inline{ obj !}        ^base !  ;m
  18. :m ->:        inline{ @ obj !}    chksame  @  put: self  ;m
  19.  
  20. :m PRINT:    ^base @  .  ;m
  21.  
  22. :m CLASSINIT:    clear: self  ;m
  23.  
  24. ;class
  25.  
  26.  
  27. :class    VAR  super{ longword }
  28.  
  29. :m +:        inline{ obj +!}    ^base +!   ;m
  30. :m -:        inline{ obj -!}    ^base -!   ;m
  31. ;class
  32.  
  33.  
  34. :class    INT    super{ object }
  35.  
  36.     2 bytes data
  37.  
  38. :m CLEAR:    inline{ 0 obj w!}    0 ^base w!  ;m
  39. :m GET:        inline{ obj w@x}    ^base w@x  ;m
  40. :m PUT:        inline{ obj w!}    ^base w!  ;m
  41. :m +:        inline{ obj w+!}    ^base w+!  ;m
  42. :m -:        inline{ obj w-!}    ^base w-!  ;m
  43. :m ->:        inline{ w@ obj w!}
  44.         chksame  w@  put: self  ;m
  45.  
  46. :m INT:        ^base w@  makeint  ;m    \ return as toolbox int
  47.  
  48. :m PRINT:    ^base w@  .  ;m
  49.  
  50. :m CLASSINIT:    clear: self  ;m
  51.  
  52. ;class
  53.  
  54. :class  UINT  super{ int }
  55.  
  56. :m GET:    inline{ obj w@}  ^base w@  ;m
  57.  
  58. ;class
  59.  
  60.  
  61. :class    BYTE    super{ object }
  62.  
  63.     1 bytes data
  64.  
  65. :m CLEAR:    inline{ 0 obj c!}    0 ^base c!  ;m
  66. :m GET:        inline{ obj c@x}    ^base c@x  ;m
  67. :m PUT:        inline{ obj c!}    ^base c!  ;m
  68. :m ->:        inline{ c@ obj c!}    chksame  c@  put: self  ;m
  69.  
  70. :m PRINT:    ^base c@  .  ;m
  71.  
  72. :m CLASSINIT:    clear: self  ;m
  73.  
  74. ;class
  75.  
  76.  
  77. :class  UBYTE  super{ byte }
  78.  
  79. :m GET:        inline{ obj c@}    ^base c@  ;m
  80.  
  81. ;class
  82.  
  83.  
  84. :class    BOOL    super{ byte }
  85.  
  86. :m PUT:        inline{ 0<> obj c!}        0<>  ^base c!  ;m
  87. :m SET:        inline{ true obj c!}    true  ^base c!  ;m
  88.  
  89. :m PRINT:    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m
  90.  
  91. ;class
  92.  
  93. \ Handle class can store handles to relocatable heap blocks.  It would be nice to store the length too, but this class is used for handles in toolbox records so we can't.  Not here at least.
  94.  
  95.     0    value    RELCNT        \ For testing - counts release: msgs
  96.                             \ to make sure we're releasing everything
  97.  
  98. :class    HANDLE    super{ longword }
  99.  
  100. :m PTR:        \ Dereferences handle to get pointer.  Trap if nil.
  101.     inline{ obj @ @}    ^base @ @  ;m
  102.  
  103. :m NPTR:        \ Dereferences handle and masks with SAmask so we can
  104.                 \ use the pointer numerically.
  105.     ^base @ @ SAmask and  ;m
  106.  
  107. :m RELEASE:        \ Deallocates the heap block, if allocated.
  108.     1 ++> relCnt  killH  ;m
  109.  
  110. :m CLEAR:    nilH  ^base !  ;m    \ We hope we know what we're doing.
  111.  
  112. :m NIL?:        \ ( -- b )
  113.     get: self  nilH =  ;m
  114.  
  115. :m SETSIZE:    \ ( size -- }
  116.     setHsz  0= ?error 166  ;m
  117.  
  118. :m SIZE:        \ ( -- size )  Gets current size.
  119.     getHSz  ;m
  120.  
  121. :m NEW:        \ ( size -- )
  122.     newH  0= ?error 166  ;m
  123.  
  124. :m LOCK:    lok    ;m
  125. :m UNLOCK:    unlok  ;m
  126.  
  127. :m GETSTATE:  ( -- state )    HgetSt  ;m
  128. :m SETSTATE:  ( state -- )    HsetSt  ;m
  129.  
  130. :m LOCKED?:   ( -- b )        HgetSt  $ 80 and  0<>  ;m
  131.  
  132. :m MOVEHI:    MvHHi  drop ( errors don't really matter here )  ;m
  133.  
  134. :m ->:        \ ( ^hdl -- )  Copies passed-in handle's heap data to self.
  135.     chkSame  copyH  ?error 167  ;m
  136.  
  137. :m PRINT:
  138.     & $ emit  ^base @  u.h  ;m    \ We assume a print: of a handle is more
  139.                                 \  useful in hex.
  140.  
  141. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  142.  
  143. ;class
  144.  
  145.  
  146. \ OBJHANDLE is a handle that points to an object in the heap.
  147.  
  148. :class    OBJHANDLE  super{ handle }
  149.  
  150. :m OBJ:        moveHi: self  lock: self  nptr: self  >obj  ;m
  151.  
  152.     \ Note: if we're going to bind to a heap-based object,
  153.     \ the handle MUST be locked while we do so - anything
  154.     \ may happen before the method returns!!  Thus we make the
  155.     \ obj: method do a moveHi and lock.  But remember to unlock
  156.     \ the handle eventually!  (Unless you're releasing it, of course.)
  157.  
  158. :m NEWOBJ:  ( #els ) { ^class -- }
  159.         \ Usage:  5  ['] someClass  newObj: someHndl
  160.  
  161.     ^class  cl>len  8 +  new: self
  162.     ^class  obj: self  make_obj  unlock: self  ;m
  163.  
  164. :m RELEASEOBJ:
  165.     nil?: self  ?exit
  166.     release: [ obj: self ]  release: super  ;m
  167.  
  168. :m RELEASE:    releaseObj: self  ;m        \ Standard destructor name.
  169.  
  170.     \ Note: we define both release: and releaseObj: so that in classes
  171.     \ HandleArray and HandleList we can distinguish between releasing the
  172.     \ current object and releasing the whole lot.  Release: is of course
  173.     \ overridden in those two classes to release the entire structure.
  174.  
  175. :m PRINT:
  176.     print: super  4 spaces  ." object: "
  177.     nil?: self
  178.     if    ." (none)"
  179.     else    print: [ obj: self ]  unlock: self
  180.     then   ;m
  181.  
  182. :m DUMP:
  183.     dump: super  cr
  184.     ." object: "
  185.     nil?: self
  186.     if    ." (none)"
  187.     else    dump: [ obj: self ]  unlock: self
  188.     then   ;m
  189.  
  190. ;class
  191.  
  192. :class    PTR     super{ longword }
  193.  
  194. :m RELEASE:        \ Deallocates the heap block, if allocated.
  195.     killP  ;m
  196.  
  197. :m NEW:   ( len -- )    newP  0= ?error 121  ;m
  198.  
  199. :m NIL?:   ( -- b )        ^base @  nilP =  ;m
  200.  
  201. :m CLEAR:    nilP  ^base !  ;m        \ We hope we know what we're doing.
  202.  
  203. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  204.  
  205. ;class
  206.  
  207.  
  208. \ DICADDR is a relocatable dictionary address class - use to store non-executable
  209. \ dictionary addresses.
  210.  
  211. :class     DICADDR  super{ longword }
  212.  
  213. :m GET:        ^base  @abs    ;m
  214. :m PUT:        ^base  reloc!    ;m
  215.  
  216. :m PRINT:    get: self  .id  ;m
  217.  
  218. :m CLASSINIT:    ['] null  put: self  ;m
  219.  
  220. ;class
  221.  
  222.  
  223. \ X-ADDR is an executable dictionary address class.  The only significant difference
  224. \ to DicAddr is that there is an Exec: method and no Get: method.  But if we ever
  225. \ have to separate code and data, having a separate class could prove very useful.
  226. \ An x-addr is the same as a Mops execution token.
  227.  
  228. :class    X-ADDR    super{ object }
  229.  
  230.     4    bytes    data
  231.  
  232. :m EXEC:        inline{ obj ex}    ^base @abs  execute  ;m
  233. :m PUT:        ^base  reloc!   ;m
  234.  
  235. :m CLASSINIT:    ['] null  put: self  ;m
  236.  
  237. ;class
  238.  
  239.  
  240. \        ============= Arrays ===============
  241.  
  242. : ?#XTS    \ ( n1 n2 -- )  Used to check that the right
  243.         \ number of stacked cfas is being passed in.
  244.     <>  ?error 171  ;    \ "Wrong number of cfas"
  245.  
  246.  
  247. \ Class INDEXED-OBJ is the generic superclass for all arrays.  Here we define
  248. \ the general indexed methods, which apply regardless of indexed width.
  249.  
  250. :class    INDEXED-OBJ  super{ object }
  251.  
  252. :m ^ELEM:    ^elem  ;m
  253.  
  254. :m LIMIT:    limit  ;m
  255.  
  256. :m WIDTH:    idxbase  6 -  w@  ;m
  257.  
  258. :m IXADDR:    idxbase  ;m
  259.  
  260. :m CLEARX:    \ Erases indexed area.
  261.     idxbase  limit  width: self  *  erase  ;m
  262. ;class
  263.  
  264.  
  265. \ ARRAY is the basic 4-byte cell array.
  266.  
  267. :class    ARRAY  super{ indexed-obj }  4 indexed
  268.  
  269. :m AT:  ( index -- n )        inline{ ix @}    ^elem4  @    ;m
  270. :m TO:  ( n index -- )        inline{ ix !}    ^elem4  !    ;m
  271. :m +TO:  ( n index -- )        inline{ ix +!}    ^elem4  +!    ;m
  272. :m -TO:  ( n index -- )        inline{ ix -!}    ^elem4  -!    ;m
  273. :m ^ELEM:  ( idx -- addr )    inline{ ix}    ^elem4    ;m
  274.  
  275. :m FILL:        \ ( value -- )  Fills all elements with value.
  276.     idxbase  limit 4*  bounds
  277.     ?do  dup  i !  4 +loop  drop  ;m
  278.  
  279. :m WIDTH:    4  ;m        \ Faster than the default in Indexed-obj.
  280.  
  281. :m GETELEM:    \ ( addr -- n )  Fetches one element at addr - saves indexing
  282.         \        step if addr is known.
  283.     @  ;m
  284.  
  285. ;class
  286.  
  287.  
  288. \ X-ARRAY can execute its elements.
  289.  
  290. :class    X-ARRAY  super{ array }
  291.  
  292. :m TO:  ( index -- )    ^elem: super  reloc!  ;m
  293.  
  294. :m EXEC:  ( index -- )
  295.     inline{ ix ex}    ^elem: self  @abs  execute  ;m
  296.  
  297. :m FILL:        \ ( xt -- )
  298.     limit nif  drop  exit  then    \ Out if no elements
  299.     idxbase  tuck  reloc!    @  fill: super  ;m
  300.  
  301. :m PUT:            \ ( xt0 ... xt(N-1) N -- )
  302.     limit  0exit            \ Out if no elements
  303.     limit ?#xts
  304.     idxbase  dup  limit 1-  4*  +
  305.     do  i reloc!  -4 +loop  ;m
  306.  
  307. :m ACTIONS:        \ A synonym for put:.  A more appropriate name to use in
  308.                 \ sub-classes such as dialogs.
  309.     put: self  ;m
  310.  
  311. private
  312.  
  313. :m PrintNxts:    \ ( n -- )
  314.     0 ?do  i ^elem: self  @abs  cr .id  loop  ;m
  315.  
  316. public
  317.  
  318. :m PRINT:        limit  printNxts: self  ;m
  319.  
  320. :m CLASSINIT:    ['] null  fill: self  ;m
  321.  
  322. ;class
  323.  
  324.  
  325. \ OBJ_ARRAY is a generic superclass which makes it easy to generate an array of 
  326. \ objects of a given class.  Just define a new class which multiply inherits from
  327. \ the given class (or classes) and OBJ_ARRAY (which must come last).  This will
  328. \ add an indexed section to each object of the new class, with elements wide
  329. \ enough to contain objects of the original class.  Then SELECT: "switches in"
  330. \ the selected element to be the "current" element, and all the normal methods
  331. \ of the class can then be used.
  332.  
  333. :class  OBJ_ARRAY  super{ object }    32767 indexed
  334.             \ The 32767 signals that the real indexed width is to be
  335.             \  taken from the other superclass(es).
  336.  
  337.     int    CURRENT
  338.  
  339. :m CURRENT:
  340.     get: current  ;m
  341.  
  342. :m SELECT:  { idx \ datalen slf -- }
  343.     idxBase 6 - w@  -> datalen   self -> slf    \ Set up
  344.     slf  get: current  ^elem  datalen  cmove    \ Switch out previous
  345.     idx  put: current
  346.     idx ^elem  slf  datalen  cmove  ;m        \ Switch in new
  347.  
  348. ;class
  349.  
  350. \        ============== Collections ================
  351.  
  352. \ Collections are ordered lists with a current size.  We implement them by
  353. \ multiply inheriting the generic (COL) class with the array class of the
  354. \ appropriate width.  We use a few tricks to avoid late binding to self
  355. \ in loops.
  356.  
  357. :class    (COL)  super{ object }
  358.  
  359.     int    SIZE            \ # elements in list
  360.  
  361. :m SIZE:    \ ( -- cursize )  Returns #elements currently in list
  362.      inline{ get: size}  get: size  ;m
  363.  
  364. :m CLEAR:    \ Set to list to null
  365.     clear: size   clearx: [self]  ;m
  366.  
  367. :m ADD:        \ ( val -- )  add value to end of list
  368.     get: size  limit  >=  ?error 137
  369.     get: size  to: [self]  1 +: size  ;m
  370.  
  371. :m LAST:        \ ( -- val )  Returns contents of end of list
  372.     get: size  dup 0=  ?error 136
  373.     1-  at: [self]  ;m
  374.  
  375. :m REMOVE:  { indx \ cnt wid addr -- }    \ Removes the element at index
  376.     get: size  indx -  1-  -> cnt
  377.     cnt 0<  ?error 136
  378.     width: [self]  -> wid
  379.     indx  ^elem: [self]  -> addr
  380.     1 -: size
  381.     cnt  0exit
  382.     addr wid +  addr  cnt wid *  cmove  ;m
  383.  
  384. :m INDEXOF:  { val \ ^self ^getelem wid addr -- indx T  | -- F }
  385.                 \ Finds a value in a collection.
  386.     self  bind_with getelem:  -> ^getelem  -> ^self
  387.     width: [self]  -> wid  idxbase -> addr
  388.     false  get: size  0
  389.     ?do
  390.         addr  ^self ^getelem  ex-method
  391.         val =  if  drop  i  true  leave  then
  392.         wid ++> addr
  393.     loop  ;m
  394.  
  395. :m PRINT:
  396.     get: size  0  ?do  i  at: [self]  cr .  loop  ;m
  397.  
  398. :m DUMP:
  399.     dump: super  ." size: "  get: size .  ;m
  400.  
  401. ;class
  402.  
  403.  
  404. \ Ordered-Collection is a collection of 4-byte cells.
  405.  
  406. :class    ORDERED-COL    super{ (col) array }
  407. ;class                        \ That's all, folks!!
  408.  
  409.  
  410. \ X-COL is a collection of execution tokens.
  411.  
  412. :class    X-COL    super{  (col)  x-array  }
  413.  
  414. :m  REMOVEXT:    \ ( xt -- )
  415.     false -> relocChk?  pad reloc!  true -> relocChk?
  416.     pad @  indexof: self  0EXIT
  417.     remove: self  ;m
  418.  
  419. :m  PRINT:
  420.     get: size  printNXts: self  ;m
  421. ;class
  422.  
  423.  
  424. \ SEQUENCE is a generic superclass for classes which have multiple items which
  425. \ frequently need to be looked at in sequence.  At present the main function of
  426. \ Sequence is to implement the EACH: method, which makes it very simple to
  427. \ deal with each element.  The usage is
  428. \
  429. \    begin  each: <obj>  while  <do something to the element>  repeat
  430. \
  431. \ Sequence can be multiply inherited with any class which implements the
  432. \ FIRST?: and NEXT?: methods.  The actual implementation details are quite
  433. \ irrelevant, as long as these methods are supported.
  434.  
  435. :class    SEQUENCE    super{ object }   general
  436.  
  437.     var    NXT_XT
  438.     var    ^SELF
  439.  
  440. :m EACH:        \ ( -- (varies) T  |  -- F )
  441.     get: nxt_xt
  442.     NIF                                \ First time in:
  443.         first?: [self]  0dup  0exit
  444.         self  bind_with next?:        \ Late-bind to next?: and cache
  445.         put: nxt_xt  put: ^self        \  the xt for the loop
  446.         true                        \ Yes, we've got the 1st element
  447.     ELSE                            \ Subsequent time in:
  448.         get: ^self  get: nxt_xt  ex-method        \ Call next?: method (cached)
  449.         if  true  else  clear: nxt_xt  false  then
  450.     THEN  ;m
  451.  
  452. :m UNEACH:    \ Use to terminate an EACH: loop before the end.
  453.     clear: nxt_xt  ;m
  454.  
  455. ;class
  456.  
  457.  
  458. \ HANDLEARRAY and HANDLELIST are for the implementation of collections
  459. \ of heap-based objects.  HandleArray has normal array properties.  Use HandleList
  460. \ if the number of elements may grow arbitrarily large, and if indexing isn't so
  461. \ important.  HandleArray also includes methods to allow the array to be used as
  462. \ a stack - needed for FileList.
  463.  
  464. :class    HANDLEARRAY    super{  objHandle  array  obj_array  }
  465.  
  466.     int    size
  467.  
  468. :m SIZE:        get: size  ;m
  469. :m SETSIZE:        put: size  ;m
  470.  
  471. :m RELEASE:
  472.     get: size  0  ?DO
  473.         i select: self  releaseObj: self
  474.     LOOP  ;m
  475.  
  476. :m PUSH:        \ ( hdl -- )
  477.     get: size  limit  >=  ?error 137
  478.     get: size  select: self  1 +: size
  479.     put: super  ;m
  480.  
  481. private
  482. :m (TOP):
  483.     get: size  dup
  484.     if    1-  select: self
  485.     else    drop  clear: current
  486.     then  ;m
  487. public
  488.  
  489. :m TOP:
  490.     get: size  0= ?error 136  (top): self  ;m
  491.  
  492. :m DROP:
  493.     get: size  dup  0= ?error 136
  494.     1-  select: self  releaseObj: self
  495.     1 -: size  (top): self  ;m
  496.  
  497. :m PUSHNEWOBJ:
  498.     0 push: self  newObj: self  ;m
  499.  
  500. :m CLEARX:    nilH  fill: self  ;m
  501.  
  502. :m  CLASSINIT:    clearX: self  clear: self  ;m
  503.  
  504. ;class
  505.  
  506.  
  507. \ HANDLELIST allows the implementation of a list of heap-based objects.  Unlike 
  508. \ HANDLEARRAY, the list can be of indefinite length.  We use a heap block to
  509. \ store the handles to the objects contiguously, rather than have a separate block 
  510. \ for each handle and link them together.  This saves on memory overhead and reduces 
  511. \ the number of memory manager calls.  It also reflects the assumption that 
  512. \ insertions and deletions into the middle of the list will be infrequent, as
  513. \ these could be more inefficient than with a linked scheme.  We expect that
  514. \ elements will normally be added to the end, and probably not removed at all,
  515. \ or not very often.
  516.  
  517. :class  HANDLELIST  super{ objHandle sequence }
  518.  
  519.     handle    THELIST
  520.     var    POS
  521.     var    SIZE
  522.  
  523. private
  524.  
  525. :m  (PUT):    \ ( hdl -- )
  526.     ptr: theList  get: pos  +  !  ;m
  527.  
  528. :m  (UPD):    get: super  (put): self  ;m
  529.  
  530. :m  (SEL):    \ ( n -- )  n is offset into theList, NOT an index.
  531.     dup  put: pos
  532.     ptr: theList  +  @  ^base !  ;m
  533. public
  534.  
  535. :m SELECT:    \ ( n -- )
  536.     4*  0  get: size 4-  within? not  ?error 134
  537.     (sel): self  ;m
  538.  
  539. :m CURRENT:    get: pos  4/  ;m
  540.  
  541. :m SIZE:    get: size 4/  ;m
  542.  
  543. \ The next two methods are needed by EACH:, but may be called directly as well.
  544. \ Note that NEXT?:  ASSUMES that the list is allocated in the heap and that a valid
  545. \ element is selected as the current element.  EACH: ensures this, since if FIRST?:
  546. \ returns false, NEXT?: is never called.  But if you call it directly, make sure this
  547. \ condition holds.
  548.  
  549. :m FIRST?:    \ ( -- b )
  550.     nil?: theList  if  false  exit  then
  551.     0 select: self  obj: self  true   ;m
  552.  
  553. :m NEXT?:  { \ nxt -- ^obj b }
  554.     unlock: super
  555.     get: pos  4+  -> nxt  nxt  get: size  >= if  false  exit  then
  556.     nxt  (sel): self  obj: self  true   ;m
  557.  
  558. private
  559.  
  560. :m (NEW):  { \ whr -- }
  561.     get: size
  562.     nif    nil?: theList
  563.         if    80  new: theList    \ Give it room to play with
  564.         else    80  setsize: theList
  565.         then
  566.     then
  567.     get: size  -> whr
  568.     whr 4+ dup  setsize: theList  put: size
  569.     whr  (sel): self  ;m
  570. public
  571.  
  572. :m NEWOBJ:    \ ( ^class -- )
  573.     (new): self  newObj: super  (upd): self   ;m
  574.  
  575. :m RELEASEOBJ:
  576.     releaseObj: super  (upd): self   ;m
  577.  
  578. :m REMOVEOBJ:  { \ whr cnt -- }        \ Removes the current element.
  579.     releaseObj: super
  580.     ptr: theList  get: pos  +  -> whr
  581.     4 -: size  get: size  get: pos  -  -> cnt
  582.     cnt if  whr 4+  whr  cnt  cmove  then
  583.     get: pos  4-  0 max  put: pos
  584.     get: size  nif  release: theList  then   ;m
  585.  
  586. :m RELEASE:
  587.     begin    each: self
  588.     while    drop  releaseObj: super    \ No point in (upd): since we're
  589.                         \  about to zap the whole list.
  590.     repeat
  591.     release: theList
  592.     clear: pos  clear: size   ;m
  593.  
  594. :m DUMP:
  595.     nil?: theList if  ." (not open)"  exit  then
  596.     dump: super  cr  ." current: "  get: pos  dup 4/ .
  597.     cr ." elements: "  cr
  598.     begin  each: self  while  dump: **  repeat
  599.     (sel): self   ;m
  600.  
  601. :m PRINT:
  602.     nil?: theList if  ." (not open)"  exit  then
  603.     get: pos
  604.     begin  each: self  while  print: **  cr  repeat
  605.     (sel): self   ;m
  606. ;class
  607.  
  608.  
  609. :class    DIC-MARK    super{ object }
  610.  
  611. #threads    array    LINKS
  612.             int        CURRENT
  613.  
  614. private
  615.  
  616. :m  SETC:  { \ addr index -- index }
  617.     0 -> addr  0 -> index
  618.     #threads FOR
  619.         i at: links  dup addr u>
  620.         if  -> addr  i -> index  else  drop  then
  621.     NEXT
  622.     index  put: current  ;m
  623. public
  624.  
  625. :m CURRENT:
  626.     get: current  at: links  ;m
  627.  
  628. :m SET:  { addr -- }
  629.     #threads FOR
  630.         context  i  2 <<  +  displace
  631.         begin    dup addr u>        \ We're 32-bit clean around here!
  632.         while    displace
  633.         repeat
  634.         i to: links
  635.     NEXT
  636.     setc: self  ;m
  637.  
  638. :m SETTOTOP:    big#  set: self  ;m
  639.  
  640. :m NEXT:  { \ lfa -- lfa }
  641.     get: current  at: links
  642.     dup -> lfa  dup  0exit
  643.     displace  get: current  to: links
  644.     setc: self  lfa  ;m
  645.  
  646. ;class
  647.  
  648. dic-mark    TheMARK
  649.  
  650.  
  651. \         ========== Resource support ===========
  652.  
  653. :class    RESOURCE  super{ handle }
  654.  
  655.     var    TYPE
  656.     int    ID
  657.  
  658. :m SET:        \ ( type id# -- )
  659.     put: ID  put: type   ;m
  660.  
  661. :m GETNEW:
  662.     get: type  get: ID  getRes  dup
  663.     NIF                            \ Failed - display type and ID
  664.         cr  addr: type  4  type  2 spaces
  665.         get: ID  .  170 die        \ Couldn't find this resource
  666.     THEN
  667.     put: super  ;m
  668.  
  669. :m GETXSTR:  { idx \ addr -- addr len }
  670.     getnew: self
  671.     ptr: self  -> addr
  672.     addr w@ 1-  idx min  -> idx
  673.     2 ++> addr
  674.     idx 0 ?DO  addr count +  -> addr  LOOP
  675.     addr count   ;m
  676.  
  677. ;class
  678.  
  679. \                ====================================
  680. \                        SOME UTILITY WORDS
  681. \                ====================================
  682.  
  683. \ Any special run-time initialization can be done conveniently by adding
  684. \ the appropriate words to the x-col INIT_ACTIONS.  These words will be
  685. \ executed on startup via EXTRA_INITS, right after OBJINIT.
  686.  
  687.     8    x-col    INIT_ACTIONS
  688.  
  689. : X     size: init_actions  0  ?do  i  exec: init_actions  loop  ;
  690.  
  691. ' x  -> extra_inits
  692.  
  693.  
  694. : SCREENBITS    \ ( -- l t r b )
  695.         \ Gets dimension coordinates of host machine's display.
  696.     $ 904 @ @  116 -
  697.     dup    @ unpack
  698.     rot 4+ @ unpack  ;
  699.  
  700.  
  701. : CHKKEY
  702.     cr ." Paused - <space> to continue"
  703.     (key)  cr  0 -> out  bl =  nif  cr decimal abort  then  ;
  704.  
  705. : ?P    sleepticks  0 -> sleepticks
  706.     ?terminal
  707.     swap -> sleepticks  0exit
  708.     (key) drop  chkKey  ;
  709.  
  710. : P    sleepticks  0 -> sleepticks
  711.     ?terminal  drop
  712.     -> sleepticks  ;
  713.  
  714. ' p    -> pause            \ This will be improved when Events is loaded
  715. ' ?p    -> ?pause
  716.  
  717.  
  718. : WORDS  { \ svbase svcurs n -- }
  719.     setToTop: theMark  0 -> out  0 -> n
  720.     base -> svbase  hex  curs -> svcurs  -curs  cr
  721.     BEGIN
  722.         next: theMark
  723.         ?dup
  724.     WHILE
  725.         1 ++> n
  726.         out 60 >
  727.         if  cr  0 -> out  ?pause  then
  728.         link> dup  6 .r  2 spaces  .id  space
  729.         20  out 20 mod -  spaces
  730.     REPEAT
  731.     svbase -> base
  732.     cr ." No of words: "  n .  cr
  733.     svcurs -> curs  ;
  734.  
  735.  
  736. false    value    ENDTRAV?    \ May be set from within a trav handler
  737.                 \ to terminate the trav
  738.  
  739. : (TRAV)  { theWord parm -- }
  740.     false -> endTrav?
  741.     BEGIN
  742.         next: theMark
  743.         dup  ['] :class  u<  if  drop  exit  then
  744.         link>  parm  theWord execute
  745.         endTrav?
  746.     UNTIL  ;
  747.  
  748. : TRAV    \ ( xt parm -- )
  749.         \ Traverses the dictionary, passing each xt and the parm
  750.         \ to the passed-in proc.
  751.  
  752.     setToTop: theMark  (trav)  ;
  753.  
  754. : TRAV-FROM    \ ( xt parm addr -- )
  755.             \ As for TRAV, but starts from the first word whose lfa is
  756.             \ below or at the given address.
  757.  
  758.     set: theMark  (trav)  ;
  759.  
  760.  
  761. \        =============== Dump ==================
  762.  
  763. \ This used to be in the Util module.  But sometimes the loading of that
  764. \ module could cause the address of what we wanted to dump to change.
  765.  
  766.     0    value    DADDR
  767.     0    value    DLEN
  768.  
  769. : U.R
  770.     >r 0 <# #s #>  r> over - spaces  type  ;
  771.  
  772. : .2    0 <#  # #  #>        type  space  ;
  773. : .4    0 <#  # # # #  #>    type  space  ;
  774.  
  775. : D.4    ( addr len -- )  bounds do  i w@  .4  2 +loop  ;
  776.  
  777. : EMIT.        \ ( c -- )
  778.     127 and  bl 126 within?  nif  drop  & .  then  emit  ;
  779.  
  780. : DLN        \ ( addr -- )
  781.     cr  dup  8 u.r  2 spaces
  782.     dup ( addr )  8 2dup d.4 space  +  8 d.4 space
  783.     16  bounds do  i c@ emit.  loop  ;
  784.  
  785.  
  786. : ?.N        \ ( n1 n2 -- n1 )
  787.     2dup = if  ." \/"  drop  else  1 .r space  then  ;
  788.  
  789. : ?.A        \ ( n1 n2 -- n1 )
  790.     2dup = if  drop  & V  emit  else  1 .r  then  ;
  791.  
  792. : .HEAD        \ ( addr len -- addr' len' )
  793.     swap  dup -16 and  swap 15 and  cr  10 spaces
  794.      8 0 do  i ?.n   i 1+ ?.n  space  2 +loop  space
  795.     16 8 do  i ?.n   i 1+ ?.n  space  2 +loop  space
  796.     16 0 do  i ?.a  loop   rot +  ;
  797.  
  798. :f DUMP  { addr len \ svBase svCurs -- }
  799.     base -> svBase  hex  curs -> svCurs  -curs
  800.     addr len  .head
  801.     2dup  -> dLen  -> dAddr        \ Save for DN
  802.     bounds  do  i dln  ?pause  16 +loop  cr
  803.     svbase -> base  svCurs -> curs  ;f
  804.  
  805. : DN        \ Dump next
  806.     dLen ++> dAddr  dAddr dLen dump  ;
  807.  
  808. : .W    '  >name 200 dump  ;
  809.  
  810. <" String
  811.  
  812. +echo
  813. \ Testing:
  814.  
  815. : h1 ." hello"  ;
  816. : h2 ." hi there!"  ;
  817.  
  818. 3 x-array xx
  819. xts{ h1 h2 h1 } put: xx
  820.